home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
MacHack 1994
/
MacHack 1994.toast
/
MacHack™94
/
Talks & Papers
/
Timothy Knox
/
yerk 3.66
/
System source
/
Class
< prev
next >
Wrap
Text File
|
1994-06-24
|
18KB
|
601 lines
\ Class/Object general properties and compilation code
\ 4/26/84 CBD Version 1.0
\ 4/26/84 CBD Speeded up ^Elem and friends
\ 4/27/84 CBD Moved rect, etc. to QD file
\ 5/02/84 CBD Removed IX-non-IX restriction
\ 5/24/84 NDI Remove selector numbering, add objlen
\ 5/26/84 CBD Took non-class stuff out
\ 5/28/84 CBD Selectors defer refs to input parm objects
\ 10/04/84 CBD Added class initialization, text messages
\ 10/11/84 CBD objPtr and objArray support
\ 10/12/84 CBD Added GET: and PUT: for arrays
\ 10/18/84 CBD converted to mcfa Values
\ 10/30/84 CBD propagate classInit: thru Ivar chains at create
\ 11/02/84 CBD objects have executable CFA
\ 11/02/84 CBD update for optimized array support in nucleus
\ 11/16/84 CBD removed objArray, etc.
\ 12/08/84 CBD ß1.0 version
\ 12/14/84 cbd removed read:, write:, etc
\ 12/15/84 cbd hashed selectors
\ 12/12/85 cdn Put CR after redefined message in :M
\ 8/01/86 cdn Added "Method redefined, within same class ****" message
\ 12/27/89 rfl changed ?isclass to check for valid ram for @
\ 1/11/90 rfl need to change traverse or at least ?cfa in nuc to protect for valid ram
\ 11/23/90 rfl Method redefined message now comes before selector for readability
\ 12/17/90 rfl added class name to above
\ 6/01/91 rfl ovblock modified for sys 7...heap is below 0;
\ 12/12/92 rfl 32 bit hash for methods; move ?rdepth to this source
\ 12/25/92 rfl changed nuc to set heapBot, heapTop in relative addr space
\ 12/26/92 rfl object name not unique error gives name of object
\ 5/28/93 rfl added within and used it in (@)
\ 6/04/93 rfl modified (build) for source documentation (line#..)
\ 3/03/94 rfl ;class now handles smudge so classes can be redefined with same name
0 value (rdepth)
: +rdepth 1 -> (rdepth) ;
: -rdepth 0 -> (rdepth) ;
: ?Rdepth (rdepth) IF rdepth 220 > ?error 116 THEN ;
: +docs true -> docs ;
: -docs false -> docs ;
: ^CLASS current @ pfa ;
\ the following offsets refer to the ^class, or Pfa of the class.
: MFA 10 + ; \ methods dictionary Latest field
: IFA 14 + ; \ ivar dict Latest field
: DFA 18 + ; \ Datalen , width of indexed area
: SFA 22 + ; \ superclass ptr field
\ Get length of object's named ivars
: @DLEN cfa @ Dfa W@ ;
\ ( SelPfa ^class -- m1cfa ) Find a method in a class
: (FINDM)
swap over mfa ((findm)) 0=
IF cr msg# 108 nfa .name
abort
ELSE swap drop THEN ;
\ ( Selhash objPfa -- objPfa m1cfa )
\ Find a method 1cfa given a selector ID
: FIND-METHOD
dup 0= ?error 103
swap over CFA @ (FINDM) ;
\ ( objAddr -- ) Look up SelID at IP and run the method
: (Defer)
w@(ip) \ objPfa selID
Swap Find-Method Cfa \ objAddr m0cfa
execute ; \ exec the m0cfa
0 Value ^Self
0 Value ^Super \ nfa of SUPER pseudo-Ivar
0 Value newObject \ object being created
1 Value rangeCheck \ true if runtime range check desired
true Value dEcho \ echo load to screen?
0 -> quitvec \ clear vectors
0 -> abortvec
0 -> objInit
'c pfind -> ufind
\ ( addr -- hashVal ) hash a name into a 16-bit word
: Hash { addr -- }
0 addr count + addr
DO 4* Dup 65535 > IF 1+ THEN
I C@ 32 - xor 65535 And
LOOP ;
: within { n lo hi -- b } n lo >= n hi <= and ;
\ check to make sure the memory addressed is within the application heap zone
: (@) ( addr -- n t or f) dup heapBot heapTop within
IF @ true ELSE drop false THEN ;
\ ( pfa -- pfa b ) returns true if a class - make sure pfa points within appl
: ?IsClass 'CODE DoClass OVER CFA (@) IF = ELSE drop false THEN ;
\ ( pfa -- pfa b ) return true if an object
:f ?IsObj
?IsClass
IF False
ELSE Dup cfa (@)
IF ?IsClass swap drop ELSE false THEN
THEN ;f
\ ( pfa -- pfa b ) return true if an object vector
: ?IsVect dup cfa (@) IF valCode = over cfa @ vectCode = or ELSE false THEN ;
\ ( pfa -- pfa b ) is ref'd word an open bracket?
: ?IsParen dup nfa 1+ c@ ascii [ = ;
\ ( -- ) ERROR if not compiling a new class definition
: ?Class Cstate 0= ?error 115 ;
\ ( classIFA -- f OR 1cfa t ) search CLASS dictionaries
: ivarFind here hash swap ((findm)) ;
\ ( -- f OR pfa t ) Determine if next word is an instance var
: vFind
bl word Cstate
IF \ class compile?
^class IFA ivarFind \ search IVAR chain
ELSE 0 THEN ; \ leave ff
\ Key to instantiation actions
\ notFnd -not previously defined
\ objTyp -defined as an object
\ classTyp -as a class
\ vecTyp -as an object vector- ptr, array, etc
\ parmTyp -as a named parm
\ parenType -open paren for defer group
\ ( #elems ^class OR ^class -- indlen )
: IDX-HDR DFA 2+ W@ DUP IF 2DUP W, W, * align THEN ;
\ ( IVnfa -- ivlfa )
: ilfa 2+ ;
\ ( ilfa -- icfa )
: ^ICLASS CFALEN + @ ;
\ ( ^class -- elWidth ) return the indexed element width for class
: @width dfa 2+ w@ ;
\ ( infa -- icfa ) transform ivar nfa to its class field
: icfa ilfa 4+ ;
\ ( ivarlfa -- #els wid idxOffs tf OR ff )
\ ( ivarNfa -- IvarNfa b ) True if nfa is Super or Self
: ?LastIvar Dup ^Self = Over ^Super = OR ;
\ InitIvar performs the classInit: method on the ivar on the stack )
Forward InitIvar
\ ( ivarNfa -- latestNfa ) -> Latest nested Ivar
: ^LatestIvar ilfa ^Iclass IFA @ ;
: ^NextIvar ILFA @ ;
\ ( ivarnfa -- ivoffs ) Return ivar's offset
: @IvarOffs ILFA 8+ W@ ;
\ ( ivarNfa -- IvarNfa newNfa t OR ivarNfa f )
: ?Nest
Dup ^LatestIvar ?LastIvar
IF Drop 0 ELSE 1 THEN ;
\ ITRAV traverses the tree of nested ivar definitions in a
\ class, building necessary indexed area headers
\ the Mstack has the base offset for nested Ivars
\ ( ivarNfa -- )
: ITRAV
BEGIN ?Rdepth ?Nest
IF Over @IvarOffs Dupm Addm Itrav THEN
Dup
ILFA dup \ DO-NODE - Build header if indexed ivar
pushm copym ^iclass -dup \ HDR-INFO
IF copym $ 0a + w@ popm 8+ w@ ( #els offs )
rot dup dfa w@ rot + swap @width ( #els truoffs wdth)
swap over -dup
IF ELSE 2drop drop 0 THEN
ELSE dropm 0 THEN \ not idx
IF CopyM + \ add in nested base offset
pushm copym newObject + w! ( ! el-width )
popm newObject + 2+ W! ( ! # els )
dup 4+ @ \ get ^class of indexed Ivar
over 8+ w@ \ get offs this ivar
copym newObject + + cfa ! \ store in cfa
THEN initIvar
^NextIvar ?LastIvar Not
WHILE REPEAT
DROP DropM ;
Forward ClassInit
\ ( #elems ^class OR ^class -- ) Compile an instance variable dictionary entry
: <VAR
pushm \ place ^class on methods stack for later
Vfind ?error 117
here dup hash w, \ compile hashed ivar name into dict
^Class IFA dup @ , ! COPYM , ( link, class )
copym @width
IF 4 ^class dfa w+! THEN \ if indexed, save 4 for cfa
^Class DFA W@ W, \ ( current dLen= offset )
copym @width dup
IF over * swap W, 4+ THEN ( #elems)
popM DFA W@ + align \ Account for named ivar lengths
^Class DFA W+! ;
\ ( -- ) Create hdr for the name at Here
: CreateHdr
Here 1+ c@ 0= ?error 118
$ 80 S, latest , current ! 0, ;
\ ( m1cfa n -- ) Execute the ncfa of word on stack
\ takes a standard Pfa = 1cfa as input
\ : mExec clen * swap 4- + Execute ;
\ ( #elems ^class OR ^class -- ) Build an instance of a class
: (BUILD)
Pushm Cstate
IF Popm <Var \ build an ivar
ELSE
\ NEWTOKEN : pulls name from stream
Here 1 and IF 0 c, THEN docs IF line# w, THEN Find
IF drop ?isVect
IF 3 ( vecTyp )
ELSE 1 ( objTyp )
THEN
ELSE 0 ( notFnd ) THEN ( -- pfa type OR 0 )
\ OBJHDR :
\ Build a public object header or just a cfa if headerless
\ If an object vector, load pfa of object into vector
\ ( {vectPfa} objType -- ) HERE is left at pfa of new object
Select{ \ on object type
0 ( notFnd ) Is{ CreateHdr }End \ not redefined
1 ( objTyp ) Is{ drop createHdr
type# 181 ( Object name not unique ) latest id. cr }End
2 ( classtyp ) Is{ abort }End \ should not get this
\ ( ind vecPfa -- ) for object vectors, execute -> code at 2cfa
3 ( vecTyp ) Is{ 0, Here swap 2 clen * swap 4- + Execute
msg# 120 }End
Default{ abort }Select
Here -> newObject
Copym here cLen - ! \ store ^class
copym DFA W@ ( dfa datalen )
Reserve \ allocate named instances
copym IDX-HDR reserve
popm IFA @ ?LastIVar not
IF 0 Pushm Itrav ELSE drop THEN
classInit
THEN ;
\ yerk grow zone function
'c null vect growZone
\ ( size -- addr ) acquire a block of nonrelocatable heap
: ovBlock { size -- addr }
size newPtr dup +base 0=
IF drop growZone size newPtr dup +base 0=
?error 121
THEN ;
\ build a new object on the heap for class. Use: Heap> className
\ gets heap, and returns relative ptr
: (heapObj) { theClass \ dLen obAddr idWid #els -- } 0 -> #els
theClass dfa w@ -> dlen theClass dfa 2+ w@ -> idWid
idWid IF -> #els THEN
dLen 4+ idWid IF idWid #els * 4+ + THEN \ get total length of obj
ovBlock 4+ -> obAddr \ get nonReloc heap, save ptr to cfa
theClass obAddr cfa ! \ create the class ptr
idWid IF idWid obAddr dLen + w! #els obAddr dLen + 2+ w! THEN
obAddr -> newObject theClass ifa @ ?LastIvar not
IF 0 PushM Itrav ELSE Drop THEN classinit obAddr ;
: heap>
@pfa ?isClass not ?error 122
state
IF Compile lit ,
Compile (heapObj) ELSE (heapObj)
THEN
; Immediate
\ ( -- ) Set CSTATE to compiling a class
: ]C 1 -> Cstate ; Immediate
: C[ 0 -> Cstate ; Immediate
\ compile hashed word for name at Here
: hash, @word hash w, ;
$ 81FE0000 variable aName 0 W, \ fake name/link
\ ( -- ) The super class of Object - top of all inheritance
: Meta
<[ 'Code doClass ^Class CFA !
here 10 allot 'code objmp swap 10 cmove \ jump to object code
aName , \ latest method pointer
0, \ latest ivar pointer -> SUPER
0, ( data len, flags)
0, ( super pointer) HERE -> ^SELF
hash, SELF \ SELF ivar
0, 0, 65535 W, ( link, ^class, offset)
Here -> ^Super \ save this address for later
hash, SUPER
^self , 0, 65535 W, ( link, ^class, offset )
^super ' meta ifa !
\ ( -- ) Build a class header with its superclass pointer
: <Super
@pfa dup \ find the superclass
dup ^Super icfa ! \ store superclass in SUPER
CFA here CFA \ Set up for cmove to sub class
26 Cmove \ create image of superclass header
^Class SFA ! \ store superclass pointer
^Class ^Self icfa ! \ store ^class in SELF's icfa
26 allot
[Compile] ]C [Compile] <[ \ in class, interpret
; Immediate
'c copym Vect caller \ late bound reference to calling object
\ ( -- b ) true if word at Here is a selector xxx:
: ?isSel here count 1- + c@ ascii : = here c@ 1 > And ;
\ get a selector from the input stream
: getSelect
@word dup c@ 15 >
?error 123
?isSel 0= ?error 124
hash ;
\ ( -- ) Build a methods dictionary entry for selector
: :M { \ selID -- }
?Class !Csp [Compile] ]>
getSelect -> selID
selID ^class mfa ((findm)) \ is method already defined?
IF type# 182 here count type ( Method redefined )
space latest id. \ add class name
^class > IF type# 183 ( , within same class **** ) THEN cr
THEN
here selID w, \ name is selector's hashed value
^class mfa dup @ \ get mfa, old link
, ! \ establish the links
\ build methods cfas
'Code M0CFA , 'Code M1CFA ,
; Immediate
\ ( -- pfa tokenID ) Determine type of token referenced by selector.
: refToken
uFind \ look for named stack parm
IF drop 4 ( parmTyp )
ELSE here latest (find) 0=
?error 125 drop ?IsClass
IF 2 ( classTyp )
ELSE ?IsVect
IF 3 ( vecTyp )
ELSE ?IsObj
IF 1 ( objTyp )
ELSE ?IsParen
IF 5 ( parenType )
ELSE 1 ?error 126
THEN
THEN
THEN
THEN
THEN ;
\ ( objpfa -- a:datalen )
: ^dlen cfa @ dfa ;
\ ( ivarPfa m1cfa ) compile an Ivar reference
: ivar, , w@ w, ; \ | 1cfa | offs |
\ ( objPfa m0cfa ) compile an object ref
: obj, swap cfa , , ; \ | objCfa | m0cfa |
\ ( selID ivPFa )
: ivarRef Find-Method ivar, ;
\ ( selID -- ) Build a reference to an object or vector
: objRef refToken
SELECT{
0 ( notFnd ) IS{ abort }END
( selID objPfa -- )
1 ( objTyp ) IS{ cfa execute
Find-Method cfa obj, }END \ normal obj ref
2 ( classTyp ) IS{ (FINDM) cfa , }END \ compile m0cfa
( selPfa vecPfa -- )
3 ( vecTyp ) IS{ cfa , Compile (defer) w, }END
4 ( parmTyp ) IS{ cfa , \ named parm- compile the pickCfa
Compile (Defer) W, }END \ auto deferred
5 ( parenType ) IS{ drop pushM 251 }END \ paren'd defer group
DEFAULT{ abort
}SELECT ;
\ ( selPfa -- ) Execute using token in stream
: runRef
@Pfa drop refToken
Select{
0 ( notFnd ) Is{ abort }End
1 ( objTyp ) Is{ cfa execute Find-Method }End
2 ( classTyp ) Is{ (Findm) }End
( selID vecPfa -- )
3 ( vecTyp ) Is{ cfa execute Find-Method }End
4 ( parmTyp ) Is{ abort }End
\ open bracket denotes a deferred ref to what
\ the paren'd group puts on the stack at runtime
5 ( parenType ) Is{ drop Pushm ' null }End
Default{ abort
}Select cfa execute ; \ execute the object, m0cfa
\ ================= Selector support ==========================
\ message is the message compiler invoked by using a selector
: message
state
IF \ Compile state
VFIND \ instance variable?
IF ivarRef \ ivar reference
ELSE objRef \ compile object/vector reference
THEN
ELSE runRef \ run state - execute object/vector ref
THEN
; Immediate
\ if parsed word is a message selector, leave cfa of message compiler
\ ( -- selID msgPfa 0 t OR f )
: msgFind
?isSel
IF Here hash \ leave selID
' message $ c1 true
ELSE pfind \ look for named parms
THEN ;
'c msgFind -> Ufind
\ Force late binding of method to object, as in SmallTalk
\ a close bracket pops the last selID from the methods stack and
\ compiles a defer: selID. This will build a deferred reference to the
\ parenthesized group.
: ] State
IF 251 ?Pairs Compile (Defer)
mdepth 0= ?error 127
popM W, \ Compile | {defer} |SelPfa|
ELSE popM Swap Find-Method Cfa \ exec state
execute
THEN
; Immediate
\ left bracket has no meaning unless preceded by a selector.
: [ true ?error 128 ; Immediate
: ;M ?Csp Compile (;M) ; Immediate
\ Leave class compilation state, and zero the class ptrs of Self and Super
: ;Class [Compile] <[ [Compile] C[
0 ^Super icfa ! 0 ^Self icfa ! latest c@ $ df and latest c! ; Immediate
: :Class [Compile] : ; Immediate
\ ( width -- ) Set a class and its subclasses to indexed
: <Indexed ?class ^class DFA 2+ W! ;
\ ( dim -- ) Set an indexed class to a multi-dimensionality
\ : <Dim
\ ?class ^class DFA 2+ W@ 0= ?error 175 \ misuse of <Dim
\ ^class DFA 2+ c! ;
\ ( index -- addr ) ( dlen ^base -M- dlen ^base ) range check
: ?Range dup 0< >R range? R> or ClassErr" 129 ;
\ ( index -- addr ) Return pointer to indexed element #
: ^Elem
?Class RangeCheck
IF Compile ?range THEN
Compile (^elem) ; Immediate
\ An object's base addr is always on top of mstack
Create ^base \ make code word alias
'Code copym here cfa !
\ length does not include cfa
\ ( -- objlen ) compute total length of object
\ - requires obj addr on mstack
: objlen
copym @dlen copym ^dlen 2+ w@ -dup
IF idxBase 2- w@ * + 4+ THEN ;
\ Define class init routine
:F classInit classinit: newObject ;F
\ ( ^ivarLfa -- ) ( ivarOffs -M- )
getSelect classInit: Constant initID
:F initIvar
initID swap 8+ \ ( selID ivPfa )
dup cfa @ \ non-0 ^class?
IF Find-Method cfa swap W@ ( 0cfa ivOffs )
copym newObject + + ( 0cfa ^data )
swap execute \ execute the 0cfa
ELSE 2drop \ don't try to init Self or Super
THEN ;F
\ clean up class compiler data on an Abort
' ;class cfa -> abortVec
\ dump will be in the Util module
Forward dmp
\ install object builder
' (build) cfa -> bldvec
\ ( -- ) error if object is not indexed
: ?ixObj
copym 4- @ ?IsClass not swap
dfa 2+ w@ 0= or classErr" 130 ;
: ?ixRange ?IxObj ?range ;
'c ?ixRange vect ?idx
: +range 'c ?ixRange -> ?idx ;
: -range 'c null -> ?idx ; \ no range checking
:CLASS Object <Super Meta
:M AT: ?idx At4 ;M ( index -- val )
:M TO: ?Idx (^elem) ! ;M ( val Index -- )
:M +TO: ?idx ++4 ;M ( incVal index -- )
:M ^ELEM: ?Idx ^elem ;M ( index -- addr )
\ Leave max #elements for array
:M LIMIT: ?ixObj limit ;M ( -- limit )
\ ( e0 e1... en -- ) indexed PUT: loads array from stack
:M PUT: ?ixObj limit 0
DO limit i- 1- (^elem) ! LOOP ;M
\ ( -- e0 e1 ...en) Indexed GET: places elements on stack
:M GET: ?ixObj limit 0 DO i at4 LOOP ;M
:M CLASS: copym cfa @ ;M \ non-IX - leave class ptr
\ ( -- addr len ) leave class name string for object
:M WIDTH: ?ixObj idxBase 4- W@ ;M \ IX - element size for array
\ ( value -- ) Fill all elements with a value
:M FILL: limit 0 DO dup i to: self LOOP drop ;M
\ ( -- ) Indexed Clear: erases indexed area
:M CLEAR: idxBase Width: self Limit: Self * Erase ;M
:M ABS: (abs) ;M \ Absolute copy of mstack
:M ADDR: copym ;M
\ ( -- addr ) Leave addr of 0th indexed element
:M IXADDR: idxBase ;M
\ ( -- len ) Return total length of object
:M LENGTH: objlen ;M
:M PRINT: copym objlen dmp ;M
:M DUMP: print: self ;M \ alias for Print:
:M CLASSINIT: ;M \ null method for object init
;CLASS
\ Bytes is used as the allocation primitive for basic classes
: BYTES ?Class ' Object <Var ^Class Dfa W+! ;
\ define code words to get and set handle sizes
\ ( handle size -- RC ) set handle size with condition code
Create setHSize
popD0
popA0
$ a024 w, \ call SetHandleSize
pushD0
next,
\ ( handle -- size ) get handle size
Create getHSize
popA0
$ a025 w, \ call GetHandleSize
pushD0
next,
<" Struct